home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / osr5 / devtools / dejagnu-971222 / usr / local / share / tcl8.0 / safeinit.tcl < prev    next >
Encoding:
Text File  |  1998-03-22  |  12.2 KB  |  462 lines
  1. # safeinit.tcl --
  2. #
  3. # This code runs in a master to manage a safe slave with Safe Tcl.
  4. # See the safe.n man page for details.
  5. #
  6. # Copyright (c) 1996-1997 Sun Microsystems, Inc.
  7. #
  8. # See the file "license.terms" for information on usage and redistribution
  9. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10. #
  11. # SCCS: @(#) safeinit.tcl 1.38 97/06/20 12:57:39
  12.  
  13. # This procedure creates a safe slave, initializes it with the
  14. # safe base and installs the aliases for the security policy mechanism.
  15.  
  16. proc tcl_safeCreateInterp {slave} {
  17.     global auto_path
  18.  
  19.     # Create the slave.
  20.     interp create -safe $slave
  21.  
  22.     # Set its auto_path
  23.     interp eval $slave [list set auto_path $auto_path]
  24.  
  25.     # And initialize it.
  26.     return [tcl_safeInitInterp $slave]
  27. }
  28.  
  29. # This procedure applies the initializations to an already existing
  30. # interpreter. It is useful when you want to enable an interpreter
  31. # created with "interp create -safe" to use security policies.
  32.  
  33. proc tcl_safeInitInterp {slave} {
  34.     upvar #0 tclSafe$slave state
  35.     global tcl_library tk_library auto_path tcl_platform
  36.  
  37.     # These aliases let the slave load files to define new commands
  38.  
  39.     interp alias $slave source {} tclSafeAliasSource $slave
  40.     interp alias $slave load {} tclSafeAliasLoad $slave
  41.  
  42.     # This alias lets the slave have access to a subset of the 'file'
  43.     # command functionality.
  44.     tclAliasSubset $slave file file dir.* join root.* ext.* tail \
  45.     path.* split
  46.  
  47.     # This alias interposes on the 'exit' command and cleanly terminates
  48.     # the slave.
  49.     interp alias $slave exit {} tcl_safeDeleteInterp $slave
  50.  
  51.     # Source init.tcl into the slave, to get auto_load and other
  52.     # procedures defined:
  53.  
  54.     if {$tcl_platform(platform) == "macintosh"} {
  55.     if {[catch {interp eval $slave [list source -rsrc Init]}]} {
  56.         if {[catch {interp eval $slave \
  57.             [list source [file join $tcl_library init.tcl]]}]} {
  58.         error "can't source init.tcl into slave $slave"
  59.         }
  60.     }
  61.     } else {
  62.     if {[catch {interp eval $slave \
  63.             [list source [file join $tcl_library init.tcl]]}]} {
  64.         error "can't source init.tcl into slave $slave"
  65.     }
  66.     }
  67.  
  68.     # Loading packages into slaves is handled by their master.
  69.     # This is overloaded to deal with regular packages and security policies
  70.  
  71.     interp alias $slave tclPkgUnknown {} tclSafeAliasPkgUnknown $slave
  72.     interp eval $slave {package unknown tclPkgUnknown}
  73.  
  74.     # We need a helper procedure to define a $dir variable and then
  75.     # do a source of the pkgIndex.tcl file
  76.     interp eval $slave \
  77.     [list proc tclPkgSource {dir args} {
  78.         if {[llength $args] == 2} {
  79.             source [lindex $args 0] [lindex $args 1]
  80.         } else {
  81.             source [lindex $args 0]
  82.         }
  83.           }]
  84.  
  85.     # Let the slave inherit a few variables
  86.     foreach varName \
  87.     {tcl_library tcl_version tcl_patchLevel \
  88.      tcl_platform(platform) auto_path} {
  89.     upvar #0 $varName var
  90.     interp eval $slave [list set $varName $var]
  91.     }
  92.  
  93.     # Other variables are predefined with set values
  94.     foreach {varName value} {
  95.         auto_noexec 1
  96.         errorCode {}
  97.         errorInfo {}
  98.         env() {}
  99.         argv0 {}
  100.         argv {}
  101.         argc 0
  102.         tcl_interactive 0
  103.         } {
  104.     interp eval $slave [list set $varName $value]
  105.     }
  106.  
  107.     # If auto_path is not set in the slave, set it to empty so it has
  108.     # a value and exists. Otherwise auto_loading and package require
  109.     # will complain.
  110.  
  111.     interp eval $slave {
  112.     if {![info exists auto_path]} {
  113.         set auto_path {}
  114.     }
  115.     }
  116.  
  117.     # If we have Tk, make the slave have the same library as us:
  118.  
  119.     if {[info exists tk_library]} {
  120.         interp eval $slave [list set tk_library $tk_library]
  121.     }
  122.  
  123.     # Stub out auto-exec mechanism in slave
  124.     interp eval $slave [list proc auto_execok {name} {return {}}]
  125.  
  126.     return $slave
  127. }
  128.  
  129. # This procedure deletes a safe slave managed by Safe Tcl and
  130. # cleans up associated state:
  131.  
  132. proc tcl_safeDeleteInterp {slave args} {
  133.     upvar #0 tclSafe$slave state
  134.  
  135.     # If the slave has a policy loaded, clean it up now.
  136.     if {[info exists state(policyLoaded)]} {
  137.     set policy $state(policyLoaded)
  138.     set proc ${policy}_PolicyCleanup
  139.     if {[string compare [info proc $proc] $proc] == 0} {
  140.         $proc $slave
  141.     }
  142.     }
  143.  
  144.     # Discard the global array of state associated with the slave, and
  145.     # delete the interpreter.
  146.     catch {unset state}
  147.     catch {interp delete $slave}
  148.  
  149.     return
  150. }
  151.  
  152. # This procedure computes the global security policy search path.
  153.  
  154. proc tclSafeComputePolicyPath {} {
  155.     global auto_path tclSafeAutoPathComputed tclSafePolicyPath
  156.  
  157.     set recompute 0
  158.     if {(![info exists tclSafePolicyPath]) ||
  159.         ("$tclSafePolicyPath" == "")} {
  160.     set tclSafePolicyPath ""
  161.     set tclSafeAutoPathComputed ""
  162.     set recompute 1
  163.     }
  164.     if {"$tclSafeAutoPathComputed" != "$auto_path"} {
  165.     set recompute 1
  166.     set tclSafeAutoPathComputed $auto_path
  167.     }
  168.     if {$recompute == 1} {
  169.     set tclSafePolicyPath ""
  170.     foreach i $auto_path {
  171.         lappend tclSafePolicyPath [file join $i policies]
  172.     }
  173.     }
  174.     return $tclSafePolicyPath
  175. }
  176.  
  177. # ---------------------------------------------------------------------------
  178. # ---------------------------------------------------------------------------
  179.  
  180. # tclSafeAliasSource is the target of the "source" alias in safe interpreters.
  181.  
  182. proc tclSafeAliasSource {slave args} {
  183.     global auto_path errorCode errorInfo
  184.  
  185.     if {[llength $args] == 2} {
  186.     if {[string compare "-rsrc" [lindex $args 0]] != 0} {
  187.         return -code error "incorrect arguments to source"
  188.     }
  189.     if {[catch {interp invokehidden $slave source -rsrc [lindex $args 1]} \
  190.          msg]} {
  191.         return -code error $msg
  192.     }
  193.     } else {
  194.     set file [lindex $args 0]
  195.     if {[catch {tclFileInPath $file $auto_path $slave} msg]} {
  196.         return -code error "permission denied"
  197.     }
  198.     set errorInfo ""
  199.     if {[catch {interp invokehidden $slave source $file} msg]} {
  200.         return -code error $msg
  201.     }
  202.     }
  203.     return $msg
  204. }
  205.  
  206. # tclSafeAliasLoad is the target of the "load" alias in safe interpreters.
  207.  
  208. proc tclSafeAliasLoad {slave file args} {
  209.     global auto_path
  210.  
  211.     if {[llength $args] == 2} {
  212.     # Trying to load into another interpreter
  213.     # Allow this for a child of the slave, or itself
  214.     set other [lindex $args 1]
  215.     foreach x $slave y $other {
  216.         if {[string length $x] == 0} {
  217.         break
  218.         } elseif {[string compare $x $y] != 0} {
  219.         return -code error "permission denied"
  220.         }
  221.     }
  222.     set slave $other
  223.     }
  224.  
  225.     if {[string length $file] && \
  226.         [catch {tclFileInPath $file $auto_path $slave} msg]} {
  227.     return -code error "permission denied"
  228.     }
  229.     if {[catch {
  230.     switch [llength $args] {
  231.         0 {
  232.         interp invokehidden $slave load $file
  233.         }
  234.         1 -
  235.         2 {
  236.         interp invokehidden $slave load $file [lindex $args 0]
  237.         }
  238.         default {
  239.         error "too many arguments to load"
  240.         }
  241.     }
  242.     } msg]} {
  243.     return -code error $msg
  244.     }
  245.     return $msg
  246. }
  247.  
  248. # tclFileInPath raises an error if the file is not found in
  249. # the list of directories contained in path.
  250.  
  251. proc tclFileInPath {file path slave} {
  252.     set realcheckpath [tclSafeCheckAutoPath $path $slave]
  253.     set pwd [pwd]
  254.     if {[file isdirectory $file]} {
  255.     error "$file: not found"
  256.     }
  257.     set parent [file dirname $file]
  258.     if {[catch {cd $parent} msg]} {
  259.     error "$file: not found"
  260.     }
  261.     set realfilepath [file split [pwd]]
  262.     foreach dir $realcheckpath {
  263.     set match 1
  264.     foreach a [file split $dir] b $realfilepath {
  265.         if {[string length $a] == 0} {
  266.         break
  267.         } elseif {[string compare $a $b] != 0} {
  268.         set match 0
  269.         break
  270.         }
  271.     }
  272.     if {$match} {
  273.         cd $pwd
  274.         return 1
  275.     }
  276.     }
  277.     cd $pwd
  278.     error "$file: not found"
  279. }
  280.  
  281. # This procedure computes our expanded copy of the path, as needed.
  282. # It returns the path after expanding out all aliases.
  283.  
  284. proc tclSafeCheckAutoPath {path slave} {
  285.     global auto_path
  286.     upvar #0 tclSafe$slave state
  287.  
  288.     if {![info exists state(expanded_auto_path)]} {
  289.     # Compute for the first time:
  290.     set state(cached_auto_path) $path
  291.     } elseif {"$state(cached_auto_path)" != "$path"} {
  292.     # The value of our path changed, so recompute:
  293.     set state(cached_auto_path) $path
  294.     } else {
  295.     # No change: no need to recompute.
  296.     return $state(expanded_auto_path)
  297.     }
  298.  
  299.     set pwd [pwd]
  300.     set state(expanded_auto_path) ""
  301.     foreach dir $state(cached_auto_path) {
  302.     if {![catch {cd $dir}]} {
  303.         lappend state(expanded_auto_path) [pwd]
  304.     }
  305.     }
  306.     cd $pwd
  307.     return $state(expanded_auto_path)
  308. }
  309.  
  310. proc tclSafeAliasPkgUnknown {slave package version {exact {}}} {
  311.     tclSafeLoadPkg $slave $package $version $exact
  312. }
  313.  
  314. proc tclSafeLoadPkg {slave package version exact} {
  315.     if {[string length $version] == 0} {
  316.     set version 1.0
  317.     }
  318.     tclSafeLoadPkgInternal $slave $package $version $exact 0
  319. }
  320.  
  321. proc tclSafeLoadPkgInternal {slave package version exact round} {
  322.     global auto_path
  323.     upvar #0 tclSafe$slave state
  324.  
  325.     # Search the policy path again; it might have changed in the meantime.
  326.  
  327.     if {$round == 1} {
  328.     tclSafeResearchPolicyPath
  329.  
  330.     if {[tclSafeLoadPolicy $slave $package $version]} {
  331.         return
  332.     }
  333.     }
  334.  
  335.     # Try to load as a policy.
  336.  
  337.     if [tclSafeLoadPolicy $slave $package $version] {
  338.     return
  339.     }
  340.  
  341.     # The package is not a security policy, so do the regular setup.
  342.  
  343.     # Here we run tclPkgUnknown in the master, but we hijack
  344.     # the source command so the setup ends up happening in the slave.
  345.  
  346.     rename source source.orig
  347.     proc source {args} "upvar dir dir
  348.     interp eval [list $slave] tclPkgSource \[list \$dir\] \$args"
  349.  
  350.     if [catch {tclPkgUnknown $package $version $exact} err] {
  351.     global errorInfo
  352.  
  353.     rename source {}
  354.     rename source.orig source
  355.  
  356.     error "$err\n$errorInfo"
  357.     }
  358.     rename source {}
  359.     rename source.orig source
  360.  
  361.     # If we are in the first round, check if the package
  362.     # is now known in the slave:
  363.  
  364.     if {$round == 0} {
  365.         set ifneeded \
  366.         [interp eval $slave [list package ifneeded $package $version]]
  367.  
  368.     if {"$ifneeded" == ""} {
  369.         return [tclSafeLoadPkgInternal $slave $package $version $exact 1]
  370.     }
  371.     }
  372. }
  373.  
  374. proc tclSafeResearchPolicyPath {} {
  375.     global tclSafePolicyPath auto_index auto_path
  376.  
  377.     # If there was no change, do not search again.
  378.  
  379.     if {![info exists tclSafePolicyPath]} {
  380.     set tclSafePolicyPath ""
  381.     }
  382.     set oldPolicyPath $tclSafePolicyPath
  383.     set newPolicyPath [tclSafeComputePolicyPath]
  384.     if {"$newPolicyPath" == "$oldPolicyPath"} {
  385.     return
  386.     }
  387.  
  388.     # Loop through the path from back to front so early directories
  389.     # end up overriding later directories.  This code is like auto_load,
  390.     # but only new-style tclIndex files (version 2) are supported.
  391.  
  392.     for {set i [expr [llength $newPolicyPath] - 1]} \
  393.         {$i >= 0} \
  394.         {incr i -1} {
  395.     set dir [lindex $newPolicyPath $i]
  396.         set file [file join $dir tclIndex]
  397.     if {[file exists $file]} {
  398.         if {[catch {source $file} msg]} {
  399.         puts stderr "error sourcing $file: $msg"
  400.         }
  401.     }
  402.     foreach file [lsort [glob -nocomplain [file join $dir *]]] {
  403.         if {[file isdir $file]} {
  404.         set dir $file
  405.         set file [file join $file tclIndex]
  406.         if {[file exists $file]} {
  407.             if {[catch {source $file} msg]} {
  408.             puts stderr "error sourcing $file: $msg"
  409.             }
  410.         }
  411.         }
  412.     }
  413.     }
  414. }
  415.  
  416. proc tclSafeLoadPolicy {slave package version} {
  417.     upvar #0 tclSafe$slave state
  418.     global auto_index
  419.  
  420.     set proc ${package}_PolicyInit
  421.  
  422.     if {[info command $proc] == "$proc" ||
  423.         [info exists auto_index($proc)]} {
  424.     if [info exists state(policyLoaded)] {
  425.         error "security policy $state(policyLoaded) already loaded"
  426.     }    
  427.     $proc $slave $version
  428.     interp eval $slave [list package provide $package $version]
  429.     set state(policyLoaded) $package
  430.     return 1
  431.     } else {
  432.     return 0
  433.     }
  434. }
  435. # This procedure enables access from a safe interpreter to only a subset of
  436. # the subcommands of a command:
  437.  
  438. proc tclSafeSubset {command okpat args} {
  439.     set subcommand [lindex $args 0]
  440.     if {[regexp $okpat $subcommand]} {
  441.     return [eval {$command $subcommand} [lrange $args 1 end]]
  442.     }
  443.     error "not allowed to invoke subcommand $subcommand of $command"
  444. }
  445.  
  446. # This procedure installs an alias in a slave that invokes "safesubset"
  447. # in the master to execute allowed subcommands. It precomputes the pattern
  448. # of allowed subcommands; you can use wildcards in the pattern if you wish
  449. # to allow subcommand abbreviation.
  450. #
  451. # Syntax is: tclAliasSubset slave alias target subcommand1 subcommand2...
  452.  
  453. proc tclAliasSubset {slave alias target args} {
  454.     set pat ^(; set sep ""
  455.     foreach sub $args {
  456.     append pat $sep$sub
  457.     set sep |
  458.     }
  459.     append pat )\$
  460.     interp alias $slave $alias {} tclSafeSubset $target $pat
  461. }
  462.